home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / lsp / setf.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1994-05-07  |  19.9 KB  |  528 lines
  1. ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  2.  
  3. ;; This file is part of GNU Common Lisp, herein referred to as GCL
  4. ;;
  5. ;; GCL is free software; you can redistribute it and/or modify it under
  6. ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  7. ;; the Free Software Foundation; either version 2, or (at your option)
  8. ;; any later version.
  9. ;; 
  10. ;; GCL is distributed in the hope that it will be useful, but WITHOUT
  11. ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  12. ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  13. ;; License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Library General Public License 
  16. ;; along with GCL; see the file COPYING.  If not, write to the Free Software
  17. ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  
  19.  
  20. ;;;;        setf.lsp
  21. ;;;;
  22. ;;;;                                setf routines
  23.  
  24.  
  25. (in-package 'lisp)
  26.  
  27.  
  28. (export '(setf psetf shiftf rotatef
  29.           define-modify-macro defsetf
  30.           getf remf incf decf push pushnew pop
  31.           define-setf-method get-setf-method get-setf-method-multiple-value))
  32.  
  33.  
  34. (in-package 'system)
  35.  
  36.  
  37. (eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
  38. (eval-when (eval compile) (defun si:clear-compiler-properties (symbol)))
  39. (eval-when (eval compile) (setq si:*inhibit-macro-special* nil))
  40.  
  41.  
  42. ;;; DEFSETF macro.
  43. (defmacro defsetf (access-fn &rest rest)
  44.   (cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
  45.          `(eval-when(compile eval load)
  46.                  (si:putprop ',access-fn ',(car rest) 'setf-update-fn)
  47.                  (remprop ',access-fn 'setf-lambda)
  48.                  (remprop ',access-fn 'setf-method)
  49.                  (si:putprop ',access-fn
  50.                              ,(when (not (endp (cdr rest)))
  51.                                     (unless (stringp (cadr rest))
  52.                                             (error "A doc-string expected."))
  53.                                     (unless (endp (cddr rest))
  54.                                             (error "Extra arguments."))
  55.                                     (cadr rest))
  56.                              'setf-documentation)
  57.                  ',access-fn))
  58.     (t
  59.      (unless (= (list-length (cadr rest)) 1)
  60.          (error "(store-variable) expected."))
  61.          `(eval-when (compile eval load)
  62.              (si:putprop ',access-fn ',rest 'setf-lambda)
  63.                  (remprop ',access-fn 'setf-update-fn)
  64.                  (remprop ',access-fn 'setf-method)
  65.                  (si:putprop ',access-fn
  66.                              ,(find-documentation (cddr rest))
  67.                              'setf-documentation)
  68.                  ',access-fn))))
  69.  
  70.  
  71. ;;; DEFINE-SETF-METHOD macro.
  72. (defmacro define-setf-method (access-fn &rest rest &aux args env body)
  73.   (multiple-value-setq (args env) 
  74.                (get-&environment (car rest)))
  75.   (setq body (cdr rest))
  76.   (cond (env (setq args (cons env args)))
  77.     (t (setq args (cons (gensym) args))
  78.        (push `(declare (ignore ,(car args))) body)))
  79.   `(eval-when (compile eval load)
  80.           (si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method)
  81.           (remprop ',access-fn 'setf-lambda)
  82.           (remprop ',access-fn 'setf-update-fn)
  83.           (si:putprop ',access-fn
  84.                       ,(find-documentation (cdr rest))
  85.                       'setf-documentation)
  86.           ',access-fn))
  87.  
  88.  
  89. ;;; GET-SETF-METHOD.
  90. ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
  91. ;;;  and checks the number of the store variable.
  92. (defun get-setf-method (form &optional env)
  93.   (multiple-value-bind (vars vals stores store-form access-form)
  94.       (get-setf-method-multiple-value form env)
  95.     (unless (= (list-length stores) 1)
  96.         (error "Multiple store-variables are not allowed."))
  97.     (values vars vals stores store-form access-form)))
  98.  
  99.  
  100. ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
  101.  
  102. (defun get-setf-method-multiple-value (form &optional env &aux tem)
  103.   (cond ((symbolp form)
  104.      (let ((store (gensym)))
  105.        (values nil nil (list store) `(setq ,form ,store) form)))
  106.     ((or (not (consp form)) (not (symbolp (car form))))
  107.      (error "Cannot get the setf-method of ~S." form))
  108.     ((and env (setq tem (assoc (car form) (second env))))
  109.      (setq tem (macroexpand form env))
  110.      (if (eq form tem) (error "Cannot get setf-method for ~a" form))
  111.      (return-from get-setf-method-multiple-value
  112.               (get-setf-method-multiple-value tem  env)))
  113.     ((get (car form) 'setf-method)
  114.      (apply (get (car form) 'setf-method) env (cdr form)))
  115.     ((or (get (car form) 'setf-update-fn)
  116.          (setq tem (get (car form) 'si::structure-access)))
  117.      (let ((vars (mapcar #'(lambda (x)
  118.                              (declare (ignore x))
  119.                              (gensym))
  120.                          (cdr form)))
  121.            (store (gensym)))
  122.        (values vars (cdr form) (list store)
  123.                (cond (tem
  124.                (setf-structure-access (car vars) (car tem)
  125.                           (cdr tem) store))
  126.              (t
  127.                `(,(get (car form) 'setf-update-fn)
  128.                  ,@vars ,store)))
  129.            (cons (car form) vars))))
  130.     ((get (car form) 'setf-lambda)
  131.      (let* ((vars (mapcar #'(lambda (x)
  132.                               (declare (ignore x))
  133.                               (gensym))
  134.                           (cdr form)))
  135.         (store (gensym))
  136.         (l (get (car form) 'setf-lambda))
  137.         ;; this looks bogus to me.  What if l is compiled?--wfs
  138.         (f `(lambda ,(car l) #'(lambda ,(cadr l) ,@(cddr l)))))
  139.        (values vars (cdr form) (list store)
  140.            (funcall (apply f vars) store)
  141.            (cons (car form) vars))))
  142.     ((macro-function (car form))
  143.      (get-setf-method-multiple-value (macroexpand form)))
  144.     (t
  145.      (error "Cannot expand the SETF form ~S." form))))
  146.  
  147.  
  148. ;;;; SETF definitions.
  149.  
  150. (defsetf car (x) (y) `(progn (rplaca ,x ,y) ,y))
  151. (defsetf cdr (x) (y) `(progn (rplacd ,x ,y), y))
  152. (defsetf caar (x) (y) `(progn (rplaca (car ,x) ,y) ,y))
  153. (defsetf cdar (x) (y) `(progn (rplacd (car ,x) ,y) ,y))
  154. (defsetf cadr (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  155. (defsetf cddr (x) (y) `(progn (rplacd (cdr ,x) ,y) ,y))
  156. (defsetf caaar (x) (y) `(progn (rplaca (caar ,x) ,y) ,y))
  157. (defsetf cdaar (x) (y) `(progn (rplacd (caar ,x) ,y) ,y))
  158. (defsetf cadar (x) (y) `(progn (rplaca (cdar ,x) ,y) ,y))
  159. (defsetf cddar (x) (y) `(progn (rplacd (cdar ,x) ,y) ,y))
  160. (defsetf caadr (x) (y) `(progn (rplaca (cadr ,x) ,y) ,y))
  161. (defsetf cdadr (x) (y) `(progn (rplacd (cadr ,x) ,y) ,y))
  162. (defsetf caddr (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  163. (defsetf cdddr (x) (y) `(progn (rplacd (cddr ,x) ,y) ,y))
  164. (defsetf caaaar (x) (y) `(progn (rplaca (caaar ,x) ,y) ,y))
  165. (defsetf cdaaar (x) (y) `(progn (rplacd (caaar ,x) ,y) ,y))
  166. (defsetf cadaar (x) (y) `(progn (rplaca (cdaar ,x) ,y) ,y))
  167. (defsetf cddaar (x) (y) `(progn (rplacd (cdaar ,x) ,y) ,y))
  168. (defsetf caadar (x) (y) `(progn (rplaca (cadar ,x) ,y) ,y))
  169. (defsetf cdadar (x) (y) `(progn (rplacd (cadar ,x) ,y) ,y))
  170. (defsetf caddar (x) (y) `(progn (rplaca (cddar ,x) ,y) ,y))
  171. (defsetf cdddar (x) (y) `(progn (rplacd (cddar ,x) ,y) ,y))
  172. (defsetf caaadr (x) (y) `(progn (rplaca (caadr ,x) ,y) ,y))
  173. (defsetf cdaadr (x) (y) `(progn (rplacd (caadr ,x) ,y) ,y))
  174. (defsetf cadadr (x) (y) `(progn (rplaca (cdadr ,x) ,y) ,y))
  175. (defsetf cddadr (x) (y) `(progn (rplacd (cdadr ,x) ,y) ,y))
  176. (defsetf caaddr (x) (y) `(progn (rplaca (caddr ,x) ,y) ,y))
  177. (defsetf cdaddr (x) (y) `(progn (rplacd (caddr ,x) ,y) ,y))
  178. (defsetf cadddr (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  179. (defsetf cddddr (x) (y) `(progn (rplacd (cdddr ,x) ,y) ,y))
  180. (defsetf first (x) (y) `(progn (rplaca ,x ,y) ,y))
  181. (defsetf second (x) (y) `(progn (rplaca (cdr ,x) ,y) ,y))
  182. (defsetf third (x) (y) `(progn (rplaca (cddr ,x) ,y) ,y))
  183. (defsetf fourth (x) (y) `(progn (rplaca (cdddr ,x) ,y) ,y))
  184. (defsetf fifth (x) (y) `(progn (rplaca (cddddr ,x) ,y) ,y))
  185. (defsetf sixth (x) (y) `(progn (rplaca (nthcdr 5 ,x) ,y) ,y))
  186. (defsetf seventh (x) (y) `(progn (rplaca (nthcdr 6 ,x) ,y) ,y))
  187. (defsetf eighth (x) (y) `(progn (rplaca (nthcdr 7 ,x) ,y) ,y))
  188. (defsetf ninth (x) (y) `(progn (rplaca (nthcdr 8 ,x) ,y) ,y))
  189. (defsetf tenth (x) (y) `(progn (rplaca (nthcdr 9 ,x) ,y) ,y))
  190. (defsetf rest (x) (y) `(progn (rplacd ,x ,y) ,y))
  191. (defsetf svref si:svset)
  192. (defsetf elt si:elt-set)
  193. (defsetf symbol-value set)
  194. (defsetf symbol-function si:fset)
  195. (defsetf macro-function (s) (v) `(progn (si:fset ,s (cons 'macro ,v)) ,v))
  196. (defsetf aref si:aset)
  197. (defsetf get put-aux)
  198. (defmacro put-aux (a b &rest l)
  199.   `(si::sputprop ,a ,b ,(car (last l))))
  200. (defsetf nth (n l) (v) `(progn (rplaca (nthcdr ,n ,l) ,v) ,v))
  201. (defsetf char si:char-set)
  202. (defsetf schar si:schar-set)
  203. (defsetf bit si:aset)
  204. (defsetf sbit si:aset)
  205. (defsetf fill-pointer si:fill-pointer-set)
  206. (defsetf symbol-plist si:set-symbol-plist)
  207. (defsetf gethash (k h &optional d) (v) `(si:hash-set ,k ,h ,v))
  208. (defsetf documentation (s d) (v)
  209.   `(case ,d
  210.      (variable (si:putprop ,s ,v 'variable-documentation))
  211.      (function (si:putprop ,s ,v 'function-documentation))
  212.      (structure (si:putprop ,s ,v 'structure-documentation))
  213.      (type (si:putprop ,s ,v 'type-documentation))
  214.      (setf (si:putprop ,s ,v 'setf-documentation))
  215.      (t (error "~S is an illegal documentation type." ,d))))
  216.  
  217.  
  218. (define-setf-method getf (&environment env place indicator &optional default)
  219.   (multiple-value-bind (vars vals stores store-form access-form)
  220.       (get-setf-method place env)
  221.     (let ((itemp (gensym)) (store (gensym)))
  222.       (values `(,@vars ,itemp)
  223.               `(,@vals ,indicator)
  224.               (list store)
  225.               `(let ((,(car stores) (si:put-f ,access-form ,store ,itemp)))
  226.                  ,store-form
  227.                  ,store)
  228.               `(getf ,access-form ,itemp ,default)))))
  229.  
  230. (defsetf subseq (sequence1 start1 &optional end1)
  231.         (sequence2)
  232.   `(replace ,sequence1 ,sequence2 :start1 ,start1 :end1 ,end1))
  233.  
  234. (define-setf-method the (&environment env type form)
  235.   (multiple-value-bind (vars vals stores store-form access-form)
  236.       (get-setf-method form env)
  237.     (let ((store (gensym)))
  238.       (values vars vals (list store)
  239.           `(let ((,(car stores) (the ,type ,store))) ,store-form)
  240.           `(the ,type ,access-form)))))
  241.  
  242. #|
  243. (define-setf-method apply (&environment env fn &rest rest)
  244.   (unless (and (consp fn) (eq (car fn) 'function) (symbolp (cadr fn))
  245.            (null (cddr fn)))
  246.       (error "Can't get the setf-method of ~S." fn))
  247.   (multiple-value-bind (vars vals stores store-form access-form)
  248.       (get-setf-method (cons (cadr fn) rest) env)
  249.     (unless (eq (car (last store-form)) (car (last vars)))
  250.             (error "Can't get the setf-method of ~S." fn))
  251.     (values vars vals stores
  252.         `(apply #',(car store-form) ,@(cdr store-form))
  253.         `(apply #',(cadr fn) ,@(cdr access-form)))))
  254. |#
  255.  
  256. (define-setf-method apply (&environment env fn &rest rest)
  257.   (unless (and (consp fn)
  258.                (or (eq (car fn) 'function) (eq (car fn) 'quote))
  259.                (symbolp (cadr fn))
  260.                (null (cddr fn)))
  261.     (error "Can't get the setf-method of ~S." fn))
  262.   (multiple-value-bind (vars vals stores store-form access-form)
  263.       (get-setf-method (cons (cadr fn) rest) env)
  264.     (cond ((eq (car (last store-form)) (car (last vars)))
  265.            (values vars vals stores
  266.                    `(apply #',(car store-form) ,@(cdr store-form))
  267.                    `(apply #',(cadr fn) ,@(cdr access-form))))
  268.           ((eq (car (last (butlast store-form))) (car (last vars)))
  269.            (values vars vals stores
  270.                    `(apply #',(car store-form)
  271.                            ,@(cdr (butlast store-form 2))
  272.                            (append ,(car (last (butlast store-form)))
  273.                                    (list ,(car (last store-form)))))
  274.                    `(apply #',(cadr fn) ,@(cdr access-form))))
  275.           (t (error "Can't get the setf-method of ~S." fn)))))
  276.  
  277. (define-setf-method char-bit (&environment env char name)
  278.   (multiple-value-bind (temps vals stores store-form access-form)
  279.       (get-setf-method char env)
  280.     (let ((ntemp (gensym))
  281.       (store (gensym))
  282.       (stemp (first stores)))
  283.       (values `(,ntemp ,@temps)
  284.           `(,name ,@vals)
  285.           (list store)
  286.           `(let ((,stemp (set-char-bit ,access-form ,ntemp ,store)))
  287.              ,store-form ,store)
  288.           `(char-bit ,access-form ,ntemp)))))
  289.  
  290. (define-setf-method ldb (&environment env bytespec int)
  291.   (multiple-value-bind (temps vals stores store-form access-form)
  292.       (get-setf-method int env)
  293.     (let ((btemp (gensym))
  294.       (store (gensym))
  295.       (stemp (first stores)))
  296.       (values `(,btemp ,@temps)
  297.           `(,bytespec ,@vals)
  298.           (list store)
  299.           `(let ((,stemp (dpb ,store ,btemp ,access-form)))
  300.              ,store-form ,store)
  301.           `(ldb ,btemp ,access-form)))))
  302.  
  303. (define-setf-method mask-field (&environment env bytespec int)
  304.   (multiple-value-bind (temps vals stores store-form access-form)
  305.       (get-setf-method int env)
  306.     (let ((btemp (gensym))
  307.       (store (gensym))
  308.       (stemp (first stores)))
  309.       (values `(,btemp ,@temps)
  310.           `(,bytespec ,@vals)
  311.           (list store)
  312.           `(let ((,stemp (deposit-field ,store ,btemp ,access-form)))
  313.              ,store-form ,store)
  314.           `(mask-field ,btemp ,access-form)))))
  315.  
  316.  
  317. ;;; The expansion function for SETF.
  318. (defun setf-expand-1 (place newvalue env &aux g)
  319.   (when (and (consp place) (eq (car place) 'the))
  320.         (return-from setf-expand-1
  321.           (setf-expand-1 (caddr place) `(the ,(cadr place) ,newvalue) env)))
  322.   (when (symbolp place)
  323.         (return-from setf-expand-1 `(setq ,place ,newvalue)))
  324.   (when (and (consp place)
  325.            (not (or (get (car place) 'setf-lambda)
  326.             (get (car place) 'setf-update-fn))))
  327.       (multiple-value-setq (place g) (macroexpand place env))
  328.       (if g (return-from setf-expand-1 (setf-expand-1 place newvalue env))))
  329.   (when (and (symbolp (car place)) (setq g (get (car place) 'setf-update-fn)))
  330.         (return-from setf-expand-1 `(,g ,@(cdr place) ,newvalue)))
  331.   (cond ((and (symbolp (car place))
  332.           (setq g (get (car place) 'structure-access)))
  333.      (return-from setf-expand-1
  334.        (setf-structure-access (cadr place) (car g) (cdr g) newvalue))))
  335.          
  336.   (multiple-value-bind (vars vals stores store-form access-form)
  337.       (get-setf-method place env)
  338.     (declare (ignore access-form))
  339.     `(let* ,(mapcar #'list
  340.             (append vars stores)
  341.             (append vals (list newvalue)))
  342.        ,store-form)))
  343.  
  344. (defun setf-structure-access (struct type index newvalue)
  345.   (case type
  346.     (list `(si:rplaca-nthcdr ,struct ,index ,newvalue))
  347.     (vector `(si:elt-set ,struct ,index ,newvalue))
  348.     (t `(si::structure-set ,struct ',type ,index ,newvalue))))
  349.  
  350. (defun setf-expand (l env)
  351.   (cond ((endp l) nil)
  352.         ((endp (cdr l)) (error "~S is an illegal SETF form." l))
  353.         (t
  354.          (cons (setf-expand-1 (car l) (cadr l) env)
  355.                (setf-expand (cddr l) env)))))
  356.  
  357.  
  358. ;;; SETF macro.
  359.  
  360. (defun setf-helper (rest env)
  361.   (setq rest (cdr rest))
  362.   (cond ((endp rest) nil)
  363.         ((endp (cdr rest)) (error "~S is an illegal SETF form." rest))
  364.         ((endp (cddr rest)) (setf-expand-1 (car rest) (cadr rest) env))
  365.         (t (cons 'progn (setf-expand rest env)))))
  366.  
  367. ;(setf (macro-function 'setf) 'setf-help)
  368. (si::fset 'setf (cons 'macro (symbol-function 'setf-helper)))
  369.  
  370. ;;; PSETF macro.
  371.  
  372. (defmacro psetf (&environment env &rest rest)
  373.   (cond ((endp rest) nil)
  374.         ((endp (cdr rest)) (error "~S is an illegal PSETF form." rest))
  375.         ((endp (cddr rest))
  376.          `(progn ,(setf-expand-1 (car rest) (cadr rest) env)
  377.                  nil))
  378.         (t
  379.      (do ((r rest (cddr r))
  380.           (pairs nil)
  381.           (store-forms nil))
  382.          ((endp r)
  383.           `(let* ,pairs
  384.          ,@(nreverse store-forms)
  385.          nil))
  386.        (when (endp (cdr r)) (error "~S is an illegal PSETF form." rest))
  387.        (multiple-value-bind (vars vals stores store-form access-form)
  388.            (get-setf-method (car r) env)
  389.              (declare (ignore access-form))
  390.          (setq store-forms (cons store-form store-forms))
  391.          (setq pairs
  392.            (nconc pairs
  393.               (mapcar #'list
  394.                   (append vars stores)
  395.                   (append vals (list (cadr r)))))))))))
  396.  
  397.  
  398. ;;; SHIFTF macro.
  399. (defmacro shiftf (&environment env &rest rest )
  400.   (do ((r rest (cdr r))
  401.        (pairs nil)
  402.        (stores nil)
  403.        (store-forms nil)
  404.        (g (gensym))
  405.        (access-forms nil))
  406.       ((endp (cdr r))
  407.        (setq stores (nreverse stores))
  408.        (setq store-forms (nreverse store-forms))
  409.        (setq access-forms (nreverse access-forms))
  410.        `(let* ,(nconc pairs
  411.               (list (list g (car access-forms)))
  412.               (mapcar #'list stores (cdr access-forms))
  413.               (list (list (car (last stores)) (car r))))
  414.         ,@store-forms
  415.         ,g))
  416.     (multiple-value-bind (vars vals stores1 store-form access-form)
  417.     (get-setf-method (car r) env)
  418.       (setq pairs (nconc pairs (mapcar #'list vars vals)))
  419.       (setq stores (cons (car stores1) stores))
  420.       (setq store-forms (cons store-form store-forms))
  421.       (setq access-forms (cons access-form access-forms)))))
  422.  
  423.  
  424. ;;; ROTATEF macro.
  425. (defmacro rotatef (&environment env &rest rest )
  426.   (do ((r rest (cdr r))
  427.        (pairs nil)
  428.        (stores nil)
  429.        (store-forms nil)
  430.        (access-forms nil))
  431.       ((endp r)
  432.        (setq stores (nreverse stores))
  433.        (setq store-forms (nreverse store-forms))
  434.        (setq access-forms (nreverse access-forms))
  435.        `(let* ,(nconc pairs
  436.               (mapcar #'list stores (cdr access-forms))
  437.               (list (list (car (last stores)) (car access-forms))))
  438.         ,@store-forms
  439.         nil
  440.         ))
  441.     (multiple-value-bind (vars vals stores1 store-form access-form)
  442.     (get-setf-method (car r) env)
  443.       (setq pairs (nconc pairs (mapcar #'list vars vals)))
  444.       (setq stores (cons (car stores1) stores))
  445.       (setq store-forms (cons store-form store-forms))
  446.       (setq access-forms (cons access-form access-forms)))))
  447.  
  448.  
  449. ;;; DEFINE-MODIFY-MACRO macro.
  450. (defmacro define-modify-macro (name lambda-list function &optional doc-string)
  451.   (let ((update-form
  452.      (do ((l lambda-list (cdr l))
  453.           (vs nil))
  454.          ((null l) `(list ',function access-form ,@(nreverse vs)))
  455.        (unless (eq (car l) '&optional)
  456.            (if (eq (car l) '&rest)
  457.                (return `(list* ',function
  458.                        access-form
  459.                        ,@(nreverse vs)
  460.                        ,(cadr l))))
  461.            (if (symbolp (car l))
  462.                (setq vs (cons (car l) vs))
  463.                (setq vs (cons (caar l) vs)))))))
  464.     `(defmacro ,name (&environment env reference . ,lambda-list)
  465.        ,@(if doc-string (list doc-string))
  466.        (when (symbolp reference)
  467.              (return-from ,name
  468.                (let ((access-form reference))
  469.                  (list 'setq reference ,update-form))))
  470.        (multiple-value-bind (vars vals stores store-form access-form)
  471.        (get-setf-method reference env)
  472.          (list 'let*
  473.            (mapcar #'list
  474.                (append vars stores)
  475.                (append vals (list ,update-form)))
  476.            store-form))))))))))))))))))))
  477.  
  478.  
  479. ;;; Some macro definitions.
  480.  
  481. (defmacro remf (&environment env place indicator)
  482.   (multiple-value-bind (vars vals stores store-form access-form)
  483.       (get-setf-method place env)
  484.     `(let* ,(mapcar #'list vars vals)
  485.        (multiple-value-bind (,(car stores) flag)
  486.            (si:rem-f ,access-form ,indicator)
  487.          ,store-form
  488.          flag))))
  489.  
  490. (define-modify-macro incf (&optional (delta 1)) +)
  491. (define-modify-macro decf (&optional (delta 1)) -)
  492.  
  493. (defmacro push (&environment env item place)
  494.   (when (symbolp place)
  495.         (return-from push `(setq ,place (cons ,item ,place))))
  496.   (multiple-value-bind (vars vals stores store-form access-form)
  497.       (get-setf-method place env)
  498.     `(let* ,(mapcar #'list
  499.             (append vars stores)
  500.             (append vals (list (list 'cons item access-form))))
  501.        ,store-form)))
  502.  
  503. (defmacro pushnew (&environment env item place &rest rest)
  504.   (cond ((symbolp place)
  505.      (return-from pushnew `(setq ,place (adjoin ,item ,place ,@rest)))))
  506.   (multiple-value-bind (vars vals stores store-form access-form)
  507.       (get-setf-method place env)
  508.     `(let* ,(mapcar #'list
  509.             (append vars stores)
  510.             (append vals
  511.                 (list (list* 'adjoin item access-form rest))))
  512.        ,store-form)))
  513.  
  514. (defmacro pop (&environment env place)
  515.   (when (symbolp place)
  516.         (return-from pop
  517.           (let ((temp (gensym)))
  518.             `(let ((,temp (car ,place)))
  519.                 (setq ,place (cdr ,place))
  520.                 ,temp))))
  521.   (multiple-value-bind (vars vals stores store-form access-form)
  522.       (get-setf-method place env)
  523.     `(let* ,(mapcar #'list
  524.             (append vars stores)
  525.             (append vals (list (list 'cdr access-form))))
  526.        (prog1 (car ,access-form)
  527.               ,store-form))))
  528.